#lang racket
;;
;; 6.S184 IAP 2012
;;
;; PROJECT 4: Implementation of an OO System
;;            (a.k.a. "The Adventure Game")


; Racket-specific setup
(print-as-expression #f)
(print-mpair-curly-braces #f)

(require r5rs)
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (fifth x) (car (cddddr x)))
(define rest cdr)




(define (tagged-list? exp tag)
  (and (pair? exp) (eq? (car exp) tag)))

(define (self-evaluating? exp)
  (cond ((number? exp) #t)
        ((string? exp) #t)
        ((boolean? exp) #t)
        (else #f)))

(define (quoted? exp) (tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))

(define (variable? exp) (symbol? exp))
(define (assignment? exp) (tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (make-assignment var expr)
  (list 'set! var expr))

(define (definition? exp) (tagged-list? exp 'define))
(define (definition-variable exp)
  (if (symbol? (cadr exp))   (cadr exp)   (caadr exp)))
(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp) (cddr exp))))  ; formal params, body
(define (make-define var expr)
  (list 'define var expr))

(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters lambda-exp) (cadr lambda-exp))
(define (lambda-body lambda-exp) (cddr lambda-exp))
(define (make-lambda parms body) (cons 'lambda (cons parms body)))

(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp) (cadddr exp))
(define (make-if pred conseq alt) (list 'if pred conseq alt))

(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define first-cond-clause car)
(define rest-cond-clauses cdr)
(define (make-cond seq) (cons 'cond seq))

(define (let? expr) (tagged-list? expr 'let))
(define (let-bound-variables expr) (map first (second expr)))
(define (let-values expr) (map second (second expr)))
(define (let-body expr) (cddr expr)) ;differs from lecture--body may be a sequence
(define (make-let bindings body)
  (cons 'let (cons bindings body)))

(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions begin-exp) (cdr begin-exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))
(define (make-begin exp) (cons 'begin exp))

(define (application? exp) (pair? exp))
(define (operator app) (car app))
(define (operands app) (cdr app))
(define (no-operands? args) (null? args))
(define (first-operand args) (car args))
(define (rest-operands args) (cdr args))
(define (make-application rator rands)
  (cons rator rands))

;;
;; this section is the actual implementation of oo-eval
;;

(define (oo-eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((assignment? exp) (eval-assignment exp env))
        ((definition? exp) (eval-definition exp env))
        ((if? exp) (eval-if exp env))
        ((lambda? exp)
         (make-procedure (lambda-parameters exp) (lambda-body exp) env))
        ((begin? exp) (eval-sequence (begin-actions exp) env))
        ((cond? exp) (oo-eval (cond->if exp) env))
        ((let? exp) (oo-eval (let->application exp) env))
        ((and? exp) (eval-and exp env))
        ((or? exp) (eval-or exp env))
        ((make-class? exp)(eval-make-class exp env)); Q3
        ((application? exp)
         (oo-apply (oo-eval (operator exp) env)
                (list-of-values (operands exp) env)))
        (else (oo-error "Unknown expression type -- EVAL" exp))))

(define (oo-apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment (procedure-parameters procedure)
                              arguments
                              (procedure-environment procedure))))
        ((instance? procedure) (oo-apply-instance procedure arguments)) ; Q5
        (else (oo-error "Unknown procedure type -- APPLY" procedure))))

(define (list-of-values exps env)
  (cond ((no-operands? exps) '())
        (else (cons (oo-eval (first-operand exps) env)
                    (list-of-values (rest-operands exps) env)))))

(define (eval-if exp env)
  (if (oo-eval (if-predicate exp) env)
      (oo-eval (if-consequent exp) env)
      (oo-eval (if-alternative exp) env)
      ))

(define (eval-sequence exps env)
  (cond ((last-exp? exps) (oo-eval (first-exp exps) env))
        (else (oo-eval (first-exp exps) env)
              (eval-sequence (rest-exps exps) env))))

(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (oo-eval (assignment-value exp) env)
                       env))

(define (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (oo-eval (definition-value exp) env)
                    env))

(define (let->application expr)
  (let ((names (let-bound-variables expr))
        (values (let-values expr))
        (body (let-body expr)))
    (make-application (make-lambda names body)
                      values)))

(define (cond->if expr)
  (let ((clauses (cond-clauses expr)))
    (if (null? clauses)
        #f
        (if (eq? (car (first-cond-clause clauses)) 'else)
            (sequence->exp (cdr (first-cond-clause clauses)))
            (make-if (car (first-cond-clause clauses))
                     (sequence->exp (cdr (first-cond-clause clauses)))
                     (make-cond (rest-cond-clauses clauses)))))))

(define (and? exp) (tagged-list? exp 'and))
(define (and-clauses exp) (cdr exp))

(define (eval-and exp env)
  (define (and-helper clauses)
    (let ((val (oo-eval (car clauses) env)))
      (cond ((last-pair? clauses)
             val)
            (val
             (and-helper (cdr clauses)))
            (else
             #f))))
  (if (last-pair? exp)
      #t
      (and-helper (and-clauses exp))))

(define (or? exp) (tagged-list? exp 'or))
(define (or-clauses exp) (cdr exp))

(define (eval-or exp env)
  (define (or-helper clauses)
    (let ((val (oo-eval (car clauses) env)))
      (cond ((last-pair? clauses)
             val)
            (val
             val)
            (else
             (or-helper (cdr clauses))))))
  (if (last-pair? exp)
      #f
      (or-helper (or-clauses exp))))

;; Assumes lst is not-null
(define (last-pair? lst)
  (null? (cdr lst)))

(define input-prompt ";;; OO-Eval input")
(define output-prompt ";;; OO-Eval value:")
(define error-prompt ";;; OO-Eval error:")
(define (driver-loop) (repl #f))

(define *restart-repl* #f)

(define oo-error error)

(define (oo-error-restart . msgs)
  (newline) (display error-prompt) (pretty-display msgs) (newline)
  (*restart-repl*))

(define (repl port)
  (set! oo-error oo-error-restart)
  (if (not port)
      (begin
        (call/cc (lambda (c) (set! *restart-repl* c)))
        (prompt-for-input input-prompt)))
  (let ((input (if port (read port) (read))))
    (cond ((eof-object? input)   'oo-eval-done)
          ((eq? input '**quit**) 'oo-eval-done)
          (else
           (let ((output (oo-eval input the-global-environment)))
             (if (not port)
                 (begin
                   (announce-output output-prompt)
                   (pretty-display output)))
             (repl port))))))

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string) (newline))

(define (run-file filename)
  (repl (open-input-file filename))
  'loaded)


;;
;;
;; implementation of oo-eval environment model
;;

; double bubbles
(define (make-procedure parameters body env)
  (list 'procedure parameters body env))
(define (compound-procedure? proc)
  (tagged-list? proc 'procedure))
(define (procedure-parameters proc) (second proc))
(define (procedure-body proc) (third proc))
(define (procedure-environment proc) (fourth proc))


; bindings
(define (make-binding var val)
  (list var val))
(define binding-variable car)
(define binding-value cadr)
(define (binding-search var frame)
  (if (null? frame)
      #f
      (if (eq? var (first (first frame)))
          (first frame)
          (binding-search var (rest frame)))))
(define (set-binding-value! binding val)
  (set-car! (cdr binding) val))

; frames
(define (make-frame-bindings variables values)
  (if (null? variables) '()
      (cons (make-binding (first variables)
                          (first values))
            (make-frame-bindings (rest variables)
                                 (rest values)))))
(define (make-frame variables values)
  (cons 'frame (make-frame-bindings variables values)))
(define (frame-variables frame) (map binding-variable (cdr frame)))
(define (frame-values frame) (map binding-value (cdr frame)))
(define (add-binding-to-frame! var val frame)
  (set-cdr! frame (cons (make-binding var val) (cdr frame))))
(define (find-in-frame var frame)
  (binding-search var (cdr frame)))

; environments
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

(define (find-in-environment var env)
  (if (eq? env the-empty-environment)
      #f
      (let ((frame (first-frame env)))
        (let ((binding (find-in-frame var frame)))
          (if binding
              binding
              (find-in-environment var (enclosing-environment env)))))))

; drop a frame
(define (extend-environment vars vals base-env)
  (define (helper rest-vars rest-vals)
    (cond ((and (null? rest-vars) (null? rest-vals))
           '())
          ((null? rest-vars)
           (error "Too many args supplied" vars vals))
          ((symbol? rest-vars)
           (list (list rest-vars rest-vals)))
          ((null? rest-vals)
           (error "Too few args supplied" vars vals))
          (else
           (cons (list (car rest-vars) (car rest-vals))
                 (helper (cdr rest-vars) (cdr rest-vals))))))
  (let ((matching (helper vars vals)))
    (cons (make-frame (map first matching) (map second matching)) base-env)))

(define (extend-environment-with-frame frame base-env)
  (cons frame base-env))

; name rule
(define (lookup-variable-value var env)
  (let ((binding (find-in-environment var env)))
    (if binding
        (binding-value binding)
        (oo-error "Unbound variable -- LOOKUP" var))))

(define (set-variable-value! var val env)
  (let ((binding (find-in-environment var env)))
    (if binding
        (set-binding-value! binding val)
        (oo-error "Unbound variable -- SET" var))))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (let ((binding (find-in-frame var frame)))
      (if binding
          (set-binding-value! binding val)
          (add-binding-to-frame! var val frame)))))

; primitives procedures - hooks to underlying Scheme procs
(define (make-primitive-procedure implementation)
  (list 'primitive implementation))
(define (primitive-procedure? proc) (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define (primitive-procedures)
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        (list 'memq memq)

        (list 'not not)
        (list 'eq? eq?)
        (list 'equal? equal?)
        (list 'pair? pair?)
        (list 'symbol-append
              (lambda args
                (string->symbol (apply string-append
                                       (map symbol->string args)))))

        (list '+ +)
        (list '- -)
        (list '* *)
        (list '/ /)
        (list '< <)
        (list '> >)
        (list '= =)
        (list 'random random)
        (list 'symbol-prefix? symbol-prefix?)

        (list 'display display)
        (list 'newline newline)

        (list 'run-file run-file)
        (list 'apply oo-apply)
        (list 'new make-instance)

        ))

(define (primitive-procedure-names) (map car (primitive-procedures)))

(define (primitive-procedure-objects)
  (map make-primitive-procedure (map cadr (primitive-procedures))))

(define (apply-primitive-procedure proc args)
  (apply (primitive-implementation proc) args))

; used to initialize the environment
(define (setup-environment)
  (extend-environment (primitive-procedure-names)
                      (primitive-procedure-objects)
                      the-empty-environment))


;; NEW FOR PROJECT 4
; Testing

; An instance is a 2 element list of: the symbol 'instance
; and an association list of all slot names and current values
; Note that the slots include :class, the instance's class

(define (instance? obj)
  (tagged-list? obj 'instance))

(define (instance-class inst)
  (read-slot inst ':class))
(define (instance-state inst)
  (second inst))


; Tools needed to make opaque instance abstractions, whenver I get
; around to that.  Must remember to modify instance abstraction to use
; later. -BB <PROBLEM 6>
; make-label: produces a symbol for this class to display instead of representation
(define (make-label class)
  (class-name class))

; box-instance: given an instance and a label, put that instance in the global instance table and
; return a unique id that can look it up later via lookup-instance. The key should include the
; descriptive label
(define (hide-instance label instance)
  (let ((uid (box label)))
    (hash-set! *the-instance-table* uid instance)
    uid))

; Use to test if something is an instance uid.
(define instance-uid? box?)

(define (lookup-instance instance-uid)
  (if (not (box? instance-uid))
      (oo-error "Lookup failed: Opaque instance (uid) required, but was given:" instance-uid)
      (let ((instance (hash-ref *the-instance-table* instance-uid #f)))
        (if (not instance)
            (oo-error "Could not find the object in the table. Bug or you are cheating. Given:" instance-uid)
            instance))))

(define *the-instance-table* (make-hasheq))


; What's the class of a class? You just met-ah!
(define standard-metaclass
  `(instance
    ((:class <put-class-here>)
     (:name class)
     (:parent-class #f)
     (:slots (:name :parent-class :slots :methods))
     (:methods
      ((CONSTRUCTOR ,(lambda (self name parent slots methods)
                       (write-slot! self ':name name)
                       (write-slot! self ':parent-class parent)
                       (write-slot! self ':slots slots)
                       (write-slot! self ':methods methods)))
       (GET-SLOTS ,(lambda (self)
                     (collect-state self ':slots)))
       (GET-METHODS ,(lambda (self)
                       (map car (collect-state self ':methods))))
       (HAS-METHOD? ,(lambda (self methodname)
                       (class-has-method? self methodname)))
       (GET-NAME ,(lambda (self)
                    (read-slot self ':name)))
       (GET-TYPES ,(lambda (self)
                     (collect-state self ':name)))
       (GET-CLASS ,(lambda (self) (read-slot self ':class)))
       )))))

(set-car! (cdaadr standard-metaclass) standard-metaclass)

(define (collect-state class slotname)
  (if (class? class)
      (let ((value (read-slot class slotname)))
        (append
         (if (pair? value)
             value
             (list value))
         (collect-state (class-parent class) slotname)))
      '()))

(define (read-slot instance varname)
  (let ((result (assq varname (instance-state instance))))
    (if result
        (cadr result)
        (oo-error "read-slot: No state named" varname))))

(define (write-slot! instance varname value)
  (let ((result (assq varname (instance-state instance))))
    (if result
        (set-car! (cdr result) value)
        (oo-error "write-slot!: No state named" varname))))

;(define arg '())
;(if (null? arg) '() 
 ;   cons((list (first arg) 'uninitialized) (make-list-slots (rest arg))))
(define (make-list-slots arg) (if (null? arg) '() (cons (list (first arg) 'uninitialized) (make-list-slots (rest arg))))
  ) 


; Create an object instance from a class
(define (make-instance class . args)
  (let ((instance
         (list 'instance
               (cons (list ':class class)
                     (begin 
                       ;(display 'print-in-prob-1)
                       ;(newline)
                       ;(display  (make-list-slots (collect-state class ':slots)))
                       ;(newline)
                       ;(newline)
                       
                       (make-list-slots (collect-state class ':slots)))
                            ))))  ;; PROBLEM 1

    (if (class-has-method? class 'CONSTRUCTOR)
        (method-call instance 'CONSTRUCTOR class args))

    ; return the constructed instance
    instance
))

(define (class? c) (instance? c))
(define (class-parent class)
  (read-slot class ':parent-class))
(define (class-name class)
  (method-call class 'GET-NAME (instance-class class) '()))



(define (create-class name parent-class slots methods)
  (begin
    ;(display 'print-in-prob-2)
    ;(newline)
    ;(display name)
    ;(newline)
    ;(display parent-class)
    ;(newline)
    ;(display slots)
    ;(newline)
    ;(display methods)
    ;(newline)
    ;(newline)
    (make-instance standard-metaclass name parent-class slots methods)) );; PROBLEM 2

;(display standard-metaclass)
;(newline)
;(newline)

(define (make-class? exp) (begin
                           (tagged-list? exp 'make-class))) ; Q3
(define (eval-make-class exp env)  ;; PROBLEM 3
  (let((parse-method (lambda (method-def) (begin
                                ;(display 'in-parse-methos-problem-3)
                                ;(newline)
                                ;(display (list (first method-def) (oo-eval (second method-def) env)))
                                ;(newline)
                                ;(newline)
                                (list (first method-def) (oo-eval (second method-def) env))))))
  (begin
    ;(display 'in-main-problem-3)
    ;(newline)
    ;(display (oo-eval (first (fourth exp)) env))
    ;(newline)
    ;(newline)
    (create-class (oo-eval (second exp) env) (oo-eval (third exp) env) (fourth exp) (map parse-method (fifth exp))))))


;; PROBLEM 5
(define (oo-apply-instance instance arguments)
  (if (null? arguments)
      (oo-error "Applications of instances must include a method name as the first argument. Instance:" instance)
      (let ((methodname (car arguments))
            (methodargs (cdr arguments)))
        (method-call instance methodname (instance-class instance) methodargs))))

 ;; XXX Need to insert a frame to give us slot access. Share cons cells. Hmm. -BB
(define (oo-apply-method class instance methodname proc args)
  (if (procedure? proc)
      (apply proc instance args) ;; Kludge to make the standard-metaclass' methods work and bootstrap us.
      (let* ((proc-env  (procedure-environment proc)) ;; Normal case, method defined by user through oo-eval
             (selfsuper-env (extend-environment '(self super)
                                                (list instance (make-super class instance))
                                                proc-env))
             (params-env  (extend-environment (procedure-parameters proc)
                                              args
                                              selfsuper-env)))

        (begin 
          (display 'in-prob-5)
          (newline)
          (display params-env)
          (newline)
          (newline)
          (display proc)
          (newline)
          (newline)
          (eval-sequence
         (procedure-body proc)
         params-env)))))

; builds a procedure that starts a method search at parent, for "super"
(define (make-super class instance)
  (make-primitive-procedure
   (lambda (method . args)
     (method-call instance method (class-parent class)
                  args))))

; walks up class hierarchy looking for method
(define (method-call instance method current-class args)
  (if (class? current-class)
      (let ((proc (find-class-method method current-class)))
        (if proc
            (oo-apply-method current-class instance method proc args)
            (method-call instance method (class-parent current-class) args)))
      (oo-error "No such method" method)))

; Inheritance happens here, too
(define (class-has-method? class method)
  (define (helper class)
    (cond ((not (class? class))
           #f)
          ((find-class-method method class)
           #t)
          (else (helper (class-parent class)))))
  (helper class))

; Look for a method in just the given class, no inheritance.
(define (find-class-method methodname class)
  (let ((result (assq methodname (read-slot class ':methods))))
    (if result
        (second result)
        #f)))

;; Might come in handy sometime
(define (symbol-prefix? prefix sym)
  (regexp-match (string-append "^" 
                               (symbol->string prefix)
                               ".*")
                (symbol->string sym)))

(define the-global-environment (setup-environment))

;; if outside oo-eval
(define (run-game yourname)
  (run-file "oo-world.scm")
  (oo-eval `(setup ',yourname) the-global-environment)
  (driver-loop))

;; if inside
(oo-eval
 '(define (run-game yourname)
    (run-file "oo-world.scm")
    (setup yourname))
 the-global-environment)


(define *all-tests* '())

(define (make-test desc test)
  (let ((result
         (lambda ()
           (display "RUNNING TEST: ")
           (display desc)
           (newline)
           (test error))))
    (set! *all-tests* (append *all-tests* (list result)))
    result))

(define (run-all-tests)
  (for-each (lambda (test) (display (test)) (newline)) *all-tests*))

(define (make-oo-eval-test desc exps)
  (make-test desc (lambda (fail)
                    (set! oo-error error)
                    (define-variable! 'fail
                      (make-primitive-procedure fail) the-global-environment)
                    (oo-eval '(define (verify-result msg actual expected)
                               (if (not (equal? actual expected))
                                   (fail (format "~a. Expected ~a, got: ~a" msg expected actual))
                                   'test-passed))
                            the-global-environment)
                    (eval-sequence exps the-global-environment))))

(define (verify-slots instance fail names values)
  (cond ((null? names) 'test-passed)
        ((not (equal? (read-slot instance (car names)) (car values)))
         (fail "slot" (car names) 'should 'be (car values) 'was: (read-slot instance (car names))))
        (else
         (verify-slots instance fail (cdr names) (cdr values)))))

(define problem1-test-class '(instance ((:parent-class #f) (:slots (foo bar baz)) (:methods ()))))
(define test-problem1-0slots
  (make-test "Problem 1: make-instance with no extra args."
             (lambda (fail)
               (if (not (class? problem1-test-class))
                   'skipping-because-instances-are-opaque
                   (let ((obj (make-instance problem1-test-class)))
                     (cond ((not (instance? obj))
                            (fail "make-instance did not produce an instance: " obj))
                           (else
                            (verify-slots obj fail '(foo) '(uninitialized))
                            'test-passed)))))))


(define test-problem1-3slots
  (make-test "Problem 1: make-instance with arguments (unused)."
             (lambda (fail)
               (if (not (class? problem1-test-class))
                   'skipping-because-instances-are-opaque
                   (let ((obj (make-instance problem1-test-class 1 2 3 4)))
                     (cond ((not (instance? obj))
                            (fail "make-instance did not produce an instance"))
                           (else
                            (verify-slots obj fail '(foo bar baz) '(uninitialized uninitialized uninitialized))
                            'test-passed)))))))

(define test-problem2-simple
  (make-test "Problem 2: create-class"
             (lambda (fail)
               (let* ((class (create-class 'test-class #f '(a b c) `((CONSTRUCTOR ,(lambda (self a) (write-slot! self 'a a)))))))
                 (if (not (class? class))
                     (fail "create-class did not produce a class (an instance)")
                     (begin
                       (verify-slots class fail '(:name :parent-class :slots) `(test-class #f (a b c)))
                       (let ((obj (make-instance class 1)))
                         (verify-slots obj fail '(a) '(1))
                         'test-passed)))))))

(define test-problem2-subclass
  (make-test "Problem 2: create-class with parent class"
             (lambda (fail)
               (let* ((parent (create-class 'test-class #f '(a b c) `((CONSTRUCTOR ,(lambda (self a) (write-slot! self 'a a))))))
                      (child  (create-class 'test-class-subclass parent '(d e f) '())))

                 (if (not (class? child))
                     (fail "create-class did not produce a class (an instance)")
                     (begin
                       (verify-slots child fail '(:name :parent-class :slots) `(test-class-subclass ,parent (d e f)))
                       (let ((obj (make-instance child 1)))
                         (verify-slots obj fail '(a b c d e f) '(1 uninitialized uninitialized uninitialized uninitialized uninitialized))
                         'test-passed)))))))

(define test-problem3-simple
  (make-test "Problem 3: make-class special form"
         (lambda (fail)
             (let* ((exp '(define class (make-class 'test-class #f (a b c) ((METHOD1 (lambda () 1)) (METHOD2 (lambda () 2))))))
                    (class (oo-eval `(begin ,exp class) the-global-environment)))
               (cond ((not (class? class))
                      (fail "oo-eval of make-class did not produce a class"))
                     ((not (box? class)) ; Violate abstraction if possible
                      (verify-slots class fail '(:name :parent-class :slots) '(test-class #f (a b c)))
                      (let* ((method-alist (read-slot class ':methods))
                             (names (map car method-alist))
                             (methods (map cadr method-alist)))
                        (cond ((not (= (length names) 2))
                               (fail "wrong number of methods in list. Should be 2, got:" (length names)))
                              ((not (equal? names '(METHOD1 METHOD2)))
                               (fail "wrong method names. Should be: (METHOD1 METHOD2), got:" names))
                              ((not (compound-procedure? (car methods)))
                               (fail "method1 is not a compound-procedure. Did you oo-eval the lambda expression? Got:" (car methods)))
                              ((not (compound-procedure? (cadr methods)))
                               (fail "method2 is not a compound-procedure. Did you oo-eval the lambda expression? Got:" (cadr methods)))
                              (else 'test-passed))))
                     (else 'test-passed))))))

(define test-problem3-subclass
  (make-test "Problem 3: make-class special form with subclass"
        (lambda (fail)
             (let* ((exp1 '(define parent (make-class 'test-class #f (a b c) ((METHOD1 (lambda () 1)) (METHOD2 (lambda () 2))))))
                    (exp2 '(define child (make-class 'test-class-subclass parent (d e f) ((METHOD2 (lambda () 3)) (METHOD3 (lambda () 4))))))
                    (parent (oo-eval `(begin ,exp1 parent) the-global-environment))
                    (child (oo-eval `(begin ,exp2 child) the-global-environment)))

               (cond ((not (class? child))
                      (fail "oo-eval of make-class did not produce a class"))
                     ((not (box? child)) ; Violate abstraction if possible
                      (verify-slots child fail '(:name :parent-class :slots) `(test-class-subclass ,parent (d e f)))
                      (let* ((method-alist (read-slot child ':methods))
                             (names (map car method-alist))
                             (methods (map cadr method-alist)))
                        (cond ((not (= (length names) 2))
                               (fail "wrong number of methods in list. Should be 2, got:" (length names)))
                              ((not (equal? names '(METHOD2 METHOD3)))
                               (fail "wrong method names. Should be: (METHOD2 METHOD3), got:" names))
                              ((not (compound-procedure? (car methods)))
                               (fail "method2 is not a compound-procedure. Did you oo-eval the lambda expression? Got:" (car methods)))
                              ((not (compound-procedure? (cadr methods)))
                               (fail "method3 is not a compound-procedure. Did you oo-eval the lambda expression? Got:" (cadr methods)))
                              (else 'test-passed))))
                     (else 'test-passed))))))

(define test-problem4
  (make-test "Problem 4: new with subclass"
        (lambda (fail)
             (let* ((exp1 '(define parent (make-class 'test-class #f (a b c) ((METHOD1 (lambda () 1)) (METHOD2 (lambda () 2))))))
                    (exp2 '(define *test-val* 'nothing-yet))
                    (exp3 '(define child (make-class 'test-class-subclass parent (d e f) ((CONSTRUCTOR (lambda (x) (set! *test-val* x))) (METHOD2 (lambda () 3)) (METHOD3 (lambda () 4))))))
                    (exp4 '(define obj (new child (* 2 21))))
                    (parent (oo-eval `(begin ,exp1 parent) the-global-environment))
                    (child  (oo-eval `(begin ,exp2 ,exp3 child)  the-global-environment))
                    (obj    (oo-eval `(begin ,exp4 obj)    the-global-environment))
                    (testval (oo-eval '*test-val* the-global-environment)))

               (cond ((not (instance? obj))
                      (fail "oo-eval of new did not produce an instance"))
                     ((not (= testval 42))
                      (fail "Expected CONSTRUCTOR to set test var to 42. Instead, value is: " testval))
                     ((not (box? obj)) ;; Violate abstraction if possible
                      (verify-slots obj fail '(b f c) '(uninitialized uninitialized uninitialized))
                      'test-passed)
                     (else
                      'test-passed))))))

(define test-problem4-no-args
  (make-test "Problem 4: new with subclass, no constructor args"
        (lambda (fail)
             (let* ((exp1 '(define parent (make-class 'test-class #f (a b c) ((METHOD1 (lambda () 1)) (METHOD2 (lambda () 2))))))
                    (exp2 '(define child (make-class 'test-class-subclass parent (d e f) ((METHOD2 (lambda () 3)) (METHOD3 (lambda () 4))))))
                    (exp3 '(define obj (new child)))
                    (parent (oo-eval `(begin ,exp1 parent) the-global-environment))
                    (child  (oo-eval `(begin ,exp2 child)  the-global-environment))
                    (obj    (oo-eval `(begin ,exp3 obj)    the-global-environment)))

               (cond ((not (instance? obj))
                      (fail "oo-eval of new did not produce an instance"))
                     ((not (box? obj)) ; Violate abstraction if possible
                      (verify-slots obj fail '(b f c) '(uninitialized uninitialized uninitialized))
                      'test-passed)
                     (else
                      'test-passed))))))

(define test-problem5-trivial
  (make-oo-eval-test "Problem 5: method invocation (trivial)"
                   '((define base (make-class 'BASE #f () ((METHOD1 (lambda () (+ 1 2))) (METHOD2 (lambda (x y) (* x y))))))
                     (define obj (new base))
                     (verify-result "Method invocation failed" (obj 'METHOD1) 3)
                     (verify-result "Method invocation failed" (obj 'METHOD2 2 21) 42))))

(define test-problem5-inheritance
  (make-oo-eval-test "Problem 5: method invocation (inheritance)"
                   '((define base (make-class 'BASE #f () ((METHOD1 (lambda () (+ 1 2))) (METHOD2 (lambda (x y) (* x y))))))
                     (define sub  (make-class 'SUB  base () ((METHOD3 (lambda () (/ 2 1))) (METHOD4 (lambda () (+ 2 21))))))
                     (define obj (new sub))
                     (verify-result "Method invocation failed" (obj 'METHOD4) 23)
                     (verify-result "Method invocation failed" (obj 'METHOD2 2 21) 42))))

(define test-problem5-slot-read
  (make-oo-eval-test "Problem 5: method invocation (slot reading)"
                   '((define base (make-class 'BASE #f (a b c) ((METHOD1 (lambda (a) a)))))
                     (define sub  (make-class 'SUB  base (d e f) ((METHOD3 (lambda () e)))))
                     (define obj (new sub))
                     (verify-result "Method invocation failed" (obj 'METHOD3) 'uninitialized)
                     (verify-result "Method invocation failed" (obj 'METHOD1 42) 42))))

(define test-problem5-slot-write
  (make-oo-eval-test "Problem 5: method invocation (slot writing)"
                   '((define base (make-class 'BASE #f (a b c) ((METHOD1 (lambda (a) (set! a 'lose) a)) (METHOD2 (lambda () a)))))
                     (define sub  (make-class 'SUB  base (d e f) ((METHOD3 (lambda () e)) (METHOD4 (lambda (x) (set! e (+ x 5)) e)))))
                     (define obj (new sub))
                     (verify-result "Method invocation failed" (obj 'METHOD4 21) 26)
                     (verify-result "Method invocation failed" (obj 'METHOD3) 26)
                     (verify-result "Method invocation failed" (obj 'METHOD1 5) 'lose)
                     (verify-result "Method invocation failed" (obj 'METHOD2) 'uninitialized)

                     (define base (make-class 'BASE #f (a b c) ((METHOD1 (lambda (a) a)) (METHOD2 (lambda (x) (* a x))))))
                     (define sub  (make-class 'SUB  base (d e f) ((CONSTRUCTOR (lambda (v1 v2 v3) (set! a v1) (set! e v2) (set! f v3))) (METHOD3 (lambda () e)) (METHOD4 (lambda (x) (+ x f))))))
                     (define obj (new sub 2 3 4))
                     (verify-result "Method invocation failed" (obj 'METHOD3) 3)
                     (verify-result "Method invocation failed" (obj 'METHOD4 21) 25)
                     (verify-result "Method invocation failed" (obj 'METHOD2 5) 10)
                     (verify-result "Method invocation failed" (obj 'METHOD1 42) 42))))

(define test-problem5-self-and-super
  (make-oo-eval-test "Problem 5: method invocation (self and super)"
                   '((define base (make-class 'BASE #f () ((METHOD1 (lambda () 5)) (METHOD2 (lambda () 6)))))
                     (define sub  (make-class 'SUB  base () ((METHOD3 (lambda () (+ (self 'METHOD2) (self 'METHOD1)))) (METHOD2 (lambda () (* 2 (super 'METHOD2)))))))
                     (define obj (new sub))
                     (verify-result "Method invocation failed." (obj 'METHOD2) 12)
                     (verify-result "Method invocation failed." (obj 'METHOD3) 17))))

(define test-problem6-basic
  (make-test "Problem 6: abstraction opacity"
        (lambda (fail)
          (let* ((base (create-class 'BASE #f '() '()))
                (obj (make-instance base)))
            (cond ((not (class? base)) (fail "class fails class? check"))
                  ((not (instance? obj)) (fail "instance fails instance? check"))
                  (else 'test-passed))))))

(define test-problem6-oo-eval
    (make-oo-eval-test "Problem 6: abstraction opacity in oo-eval"
                   '((define base (make-class 'BASE #f () ((METHOD1 (lambda () 5)) (METHOD2 (lambda () 6)))))
                     (define sub  (make-class 'SUB  base () ((METHOD3 (lambda () (+ (self 'METHOD2) (self 'METHOD1)))) (METHOD2 (lambda () (* 2 (super 'METHOD2)))))))
                     (define obj (new sub))
                     (cond ((pair? base) (fail "Representation of class leaked"))
                           ((pair? sub)  (fail "Representation of sub class leaked"))
                           ((pair? (sub 'GET-CLASS)) (fail "Representation of metaclass leaked"))
                           ((pair? ((sub 'GET-CLASS) 'GET-CLASS)) (fail "Representation of metaclass leaked"))
                           ((pair? obj) (fail "Representation of object leaked")))
                     (verify-result "Method invocation failed." (obj 'METHOD2) 12)
                     (verify-result "Method invocation failed." (obj 'METHOD3) 17))))


(define test-is-a
  (make-oo-eval-test "Make sure is-a works"
                   '((define root-object (make-class 'ROOT-OBJECT #f () ((GET-CLASS (lambda () :class)))))
                     (define named-object (make-class 'NAMED-OBJECT root-object (name) ((CONSTRUCTOR (lambda (_name) (set! name _name))) (NAME (lambda () name)))))
                     (define sicp (new named-object 'SICP!))
                     (define (is-a type)
                       (lambda (obj)
                         (if (memq type ((obj 'GET-CLASS) 'GET-TYPES)) #t #f)))
                     (verify-result "sicp is namedobject" ((is-a 'NAMED-OBJECT) sicp) #t)
                     (verify-result "sicp is rootobject"  ((is-a 'ROOT-OBJECT) sicp) #t)
                     (verify-result "sicp is not yourmom" ((is-a 'YOUR-MOM) sicp) #f))))


;(driver-loop)

;(test-problem1-0slots)
;(test-problem1-3slots)

;(test-problem2-simple)
;(test-problem2-subclass)

;(test-problem3-simple)
;(test-problem3-subclass)

;(test-problem4)
;(test-problem4-no-args)

;(test-problem5-trivial)
;(test-problem5-inheritance)
(test-problem5-slot-read)
(test-problem5-slot-write)
(test-problem5-self-and-super)